perm filename MIXSCR.OLD[SCR,MUS] blob
sn#523447 filedate 1980-07-13 generic text, type T, neo UTF8
00100 C***** MIXES AND LINKS FILES PUT OUT BY 'SCORE' *******
00200 C***** ALL FILES MUST HAVE THE .SCR EXTENSION *****
00300 C***** LOAD WITH RENAM.FAI
00400 C***** USE 'R LOADER'. INCLUDE '/LLIB40.OLD[1,3]'. OTHERWISE THERE
00500 C WILL BE READ ERRORS DUE TO BUGS IN CURRENT LIB40 3/77 *******
00600
00700 COMMON /VV/KL,N1,N2,N3,J,K,L,M,P1,PX,A,B,C,D,IBL
00800 COMMON /LNK/ NK,NZ(20),IP /QQQ/QQQ(144) /RRR/RRR(144)
00900 DIMENSION Q(18)
01000 EQUIVALENCE (Q,QQQ)
01100 DATA IBL/' '/
01200 TYPE 24
01300 NK=0
01400 LX=0
01500 ACCEPT 2,K,IP
01600 CALL LO2UP(K)
01700 CALL LO2UP(IP)
01800 IF(K.EQ.'L')LX=-1
01900 200 TYPE 20
02000 ACCEPT 2,N1
02100 IF(N1.EQ.IBL)GO TO 200
02200 CALL LO2UP(N1)
02300 IF(FINDIT(N1))CALL NOTFND(N1)
02400 C DO A LOOKUP FIRST OF ALL
02500 201 TYPE 22
02600 ACCEPT 2,N2
02700 CALL LO2UP(N2)
02800 IF(N2.EQ.IBL.OR.N2.EQ.N1)GO TO 201
02900 IF(FINDIT(N2))CALL NOTFND(N2)
03000 IF(LX.EQ.0)GO TO 202
03100 1000 TYPE 41
03200 ACCEPT 2,K
03300 IF(K.EQ.IBL)GO TO 202
03400 CALL LO2UP(K)
03500 C TAKES UP TO 2+10 FILES.
03600 NK=NK+1
03700 NZ(NK)=K
03800 IF(NK.LT.20)GO TO 1000
03900
04000 202 TYPE 23
04100 ACCEPT 2,N3
04200 IF(N3.EQ.IBL)GO TO 202
04300 CALL LO2UP(N3)
04400 CALL OFILE(1,N3)
04500 TYPE 300
04600 300 FORMAT(' ****** CAUTION ******'/
04700 1' ****** NEVER STOP THIS PROGRAM WHILE IT IS WORKING ******'/)
04800 CALL RENAMX(N1,'SCR',N1,'DAT')
04900 CALL RENAMX(N2,'SCR',N2,'DAT')
05000 CALL IFILE(21,N1)
05100 CALL IFILE(22,N2)
05200 TYPE 25
05300 IF(LX.EQ.0)GO TO 25
05400 CALL LINK
05500 GO TO 204
05600 25 FORMAT(/' WORKING'/)
05700 DO 1 K=1,3
05800 READ(21,2)Q
05900 WRITE(1,2)Q
06000 1 READ(22,2)Q
06100 C READS FIRST 3 LINES
06200
06300 CALL CHECK(N,QQQ,P1,21)
06400 CALL CHECK(M,RRR,PX,22)
06500 CATCHES INSERTED LINES.
06600 6 IF(PX.LT.P1)GO TO 5
06700 CALL RDWRT(N,P1,QQQ,21)
06800 IF(KL)10,6,6
06900
07000 5 CALL RDWRT(M,PX,RRR,22)
07100 IF(KL.EQ.0)GO TO 6
07200
07300 11 PX=10000
07400 GO TO 13
07500 10 P1=10000
07600 13 IF(P1.NE.10000.OR.M.NE.N)GO TO 6
07700 12 WRITE(1,7)
07800 REWIND 21
07900 REWIND 22
08000 CALL RENAMX(N1,'DAT',N1,'SCR')
08100 CALL RENAMX(N2,'DAT',N2,'SCR')
08200 204 END FILE 1
08300 CALL RENAM(N3,'DAT',N3,'SCR')
08400 TYPE 203,N3
08500 CALL EXIT
08600 203 FORMAT(/' ****** MIX FILE NAME = ',A5,'.SCR')
08700 2 FORMAT(18A5)
08800 7 FORMAT(' FINISH;')
08900 24 FORMAT(' MIXES OR LINKS SCORE LISTS.'/
09000 1' USES ".SCR" EXTENSIONS ONLY!!! '/
09100 1' BE SURE ALL HIGHER PARAMS PRINT EACH TIME.'
09200 1//' L = LINK, <CR> = MIX '$)
09300 41 FORMAT(' TYPE NEXT FILE NAME OR <CR> '$)
09400 20 FORMAT(' TYPE FILE 1 (WITHOUT EXT.) '$)
09500 22 FORMAT(/' TYPE FILE 2 '$)
09600 23 FORMAT(/' TYPE OUTPUT NAME '$)
09700 END
09800
09900 SUBROUTINE CHECK(N,Z,P1,J)
10000 COMMON /VV/KL,N1,N2,N3,JJ,KK,L,M,P,PX,LL,K,IBL
10100 1 /QQQ/QQQ(144)
10200 DIMENSION AA(50),Z(144)
10300 DATA J1/7/,J2/12/,J3/21/
10400 C J1,J2,J3 ARE POINTERS TO POS. OF DOTS IN P1,P2
10500 KL=0
10600 33 READ(J,30,END=100)Z
10700 IF(Z(J1).NE.' ')GO TO 32
10800 IF(Z(J2).NE.'.')GO TO 32
10900 IF(Z(J3).EQ.'.')GO TO 31
11000 CATCHES INSERTED LINES.
11100 32 IF(Z(2).NE.'F')GO TO 300
11200 IF(Z(3).NE.'I')GO TO 300
11300 IF(Z(4).NE.'N')GO TO 300
11400 IF(Z(5).NE.'I')GO TO 300
11500 IF(Z(6).NE.'S')GO TO 300
11600 KL=-1
11700 N='FINIS'
11800 300 CALL SHORT(Z)
11900 IF(KL)RETURN
12000 GO TO 33
12100 100 PAUSE 'DIED IN SUBR CHECK'
12200 31 REREAD 4,L,N,P1
12300 30 FORMAT(144A1)
12400 4 FORMAT(A1,A5,F)
12500 44 FORMAT(A1,20A5)
12600 END
12700
12800 SUBROUTINE SHORT(QQQ)
12900 COMMON /VV/KL,N1,N2,N3,JJ,KK,L,M,P,PX,LL,K,A,B,IBL
13000 COMMON /LNK/ NK,NZ(20),IP
13100 DIMENSION QQQ(1)
13200 DO 1 K=144,1,-1
13300 1 IF(QQQ(K).NE.' ')GO TO 2
13400 2 IF(IP.NE.IBL)TYPE 44,(QQQ(LL),LL=1,K)
13500 IF(KL)RETURN
13600 3 WRITE(1,44)(QQQ(LL),LL=1,K)
13700 44 FORMAT(144A1)
13800 END
13900
14000 SUBROUTINE RDWRT(I,P,Z,J)
14100 COMMON /VV/KL,N1,N2,N3,JJ,KK,L,M,P1,PX,LL,K,IBL
14200 DIMENSION Z(144)
14300 KL=0
14400 DO 3 K=144,1,-1
14500 3 IF(Z(K).NE.' ')GO TO 4
14600 4 WRITE(1,44)(Z(N),N=1,K)
14700 1 READ (J,44,END=100)Z
14800 DO 5 K=144,1,-1
14900 5 IF(Z(K).NE.' ')GO TO 6
15000 6 WRITE(1,44)(Z(N),N=1,K)
15100 IF(Z(1).NE.';')GO TO 1
15200 IF(Z(2).NE.'P')GO TO 1
15300 IF(Z(3).NE.'R')GO TO 1
15400 IF(Z(4).NE.'I')GO TO 1
15500 IF(Z(5).NE.'N')GO TO 1
15600 IF(Z(6).NE.'T')GO TO 1
15700 2 CALL CHECK(I,Z,P,J)
15800 RETURN
15900 44 FORMAT(144A1)
16000 100 PAUSE 'DIED IN SUBR RDWRT'
16100 END
16200
16300 SUBROUTINE LINK
16400 COMMON /VV/KL,N1,N2,N3,JJ,KK,L,M,P1,PX,LL,K,IBL
16500 COMMON /LNK/ NK,NZ(20),IP /QQQ/QQQ(144)
16600 44 FORMAT(144A1)
16700 KL=0
16800 JJ=0
16900 J=21
17000 1 READ(J,44)QQQ
17100 32 IF(QQQ(2).NE.'F')GO TO 4
17200 IF(QQQ(3).NE.'I')GO TO 4
17300 IF(QQQ(4).NE.'N')GO TO 4
17400 IF(QQQ(5).NE.'I')GO TO 4
17500 IF(QQQ(6).NE.'S')GO TO 4
17600 GO TO 2
17700 4 CALL SHORT(QQQ)
17800 IF(JJ.GT.NK)RETURN
17900 GO TO 1
18000 2 IF(J.NE.21)GO TO 3
18100 REWIND 21
18200 CALL RENAMX(N1,'DAT',N1,'SCR')
18300 J=J+1
18400 GO TO 1
18500 3 REWIND 22
18600 IF(JJ.NE.0)GO TO 6
18700 CALL RENAMX(N2,'DAT',N2,'SCR')
18800 GO TO 5
18900 6 CALL RENAMX(NZ(JJ),'DAT',NZ(JJ),'SCR')
19000 5 JJ=JJ+1
19100 IF(JJ.GT.NK)GO TO 4
19200 CALL RENAMX(NZ(JJ),'SCR',NZ(JJ),'DAT')
19300 CALL IFILE(22,NZ(JJ))
19400 GO TO 1
19500 END
19600
19700 SUBROUTINE RENAMX(J,K,L,M)
19800 CALL RENAM(J,K,L,M)
19900 TYPE 1,J,K,L,M
20000 1 FORMAT(' (RENAME -- ',A5,'.',A3,' CHANGED TO -- ',A5,'.',A3,')')
20100 END
20200
20300 SUBROUTINE NOTFND(NM)
20400 TYPE 1,NM
20500 CALL EXIT
20600 1 FORMAT(' ******* FILE ',A5,'.SCR NOT FOUND *****')
20700 END
20800
20900 SUBROUTINE LO2UP(J)
21000 C CONVERTS ALL LOWER CASE IN WORD J TO UPPER CASE.
21100 J=J.AND..NOT.((J/2).AND."201004020100)
21200 END